home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / pcl-rev4.lha / vector.lisp < prev    next >
Lisp/Scheme  |  1990-12-04  |  14KB  |  388 lines
  1. ;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Use and copying of this software and preparation of derivative works
  8. ;;; based upon this software are permitted.  Any distribution of this
  9. ;;; software or derivative works must comply with all applicable United
  10. ;;; States export control laws.
  11. ;;; 
  12. ;;; This software is made available AS IS, and Xerox Corporation makes no
  13. ;;; warranty about the software, its performance or its conformity to any
  14. ;;; specification.
  15. ;;; 
  16. ;;; Any person obtaining a copy of this software is requested to send their
  17. ;;; name and post office or electronic mail address to:
  18. ;;;   CommonLoops Coordinator
  19. ;;;   Xerox PARC
  20. ;;;   3333 Coyote Hill Rd.
  21. ;;;   Palo Alto, CA 94304
  22. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  23. ;;;
  24. ;;; Suggestions, comments and requests for improvements are also welcome.
  25. ;;; *************************************************************************
  26. ;;;
  27. ;;; Permutation vectors.
  28. ;;;
  29.  
  30. (in-package 'pcl)
  31.  
  32. (defmacro instance-slot-index (wrapper slot-name)
  33.   `(let ((pos 0))
  34.      (block loop
  35.        (dolist (sn (wrapper-instance-slots-layout ,wrapper))
  36.      (when (eq ,slot-name sn) (return-from loop pos))
  37.      (incf pos)))))
  38.  
  39.  
  40. ;;;
  41. ;;;
  42. ;;;
  43. (defmacro %isl-cache           (isl) `(%svref ,isl 1))
  44. (defmacro %isl-field           (isl) `(%svref ,isl 2))
  45. (defmacro %isl-mask            (isl) `(%svref ,isl 3))
  46. (defmacro %isl-size            (isl) `(%svref ,isl 4))
  47. (defmacro %isl-slot-name-lists (isl) `(%svref ,isl 5))
  48.  
  49. (defun make-isl (slot-name-lists)
  50.   (multiple-value-bind (mask size)
  51.       (compute-primary-pv-cache-size slot-name-lists)
  52.     (make-isl-internal (wrapper-field 'number)
  53.                (get-cache size)
  54.                mask
  55.                size
  56.                slot-name-lists)))
  57.  
  58. (defun make-isl-internal (field cache mask size slot-name-lists)  
  59.   (let ((isl (make-array 6)))
  60.     (setf (svref isl 0)               'isl
  61.       (%isl-cache isl)            cache
  62.       (%isl-field isl)            field
  63.       (%isl-mask  isl)            mask
  64.       (%isl-size  isl)            size
  65.       (%isl-slot-name-lists isl)  slot-name-lists)
  66.     isl))
  67.  
  68. (defun make-isl-type-declaration (var)
  69.   `(type simple-vector ,var))
  70.  
  71. (defun islp (x)
  72.   (and (simple-vector-p x)
  73.        (= (array-dimension x 0) 5)
  74.        (eq (svref x 0) 'isl)))
  75.  
  76. (defvar *slot-name-lists-inner* (make-hash-table :test #'equal))
  77. (defvar *slot-name-lists-outer* (make-hash-table :test #'equal))
  78.  
  79. (defun intern-slot-name-lists (slot-name-lists)
  80.   (flet ((inner (x) 
  81.        (or (gethash x *slot-name-lists-inner*)
  82.            (setf (gethash x *slot-name-lists-inner*) (copy-list x))))
  83.      (outer (x) 
  84.        (or (gethash x *slot-name-lists-outer*)
  85.            (setf (gethash x *slot-name-lists-outer*) (make-isl (copy-list x))))))
  86.     (outer (mapcar #'inner slot-name-lists))))
  87.  
  88.  
  89.  
  90. (defvar *pvs* (make-hash-table :test #'equal))
  91.  
  92. (defvar default-svuc-method nil)
  93. (defvar default-setf-svuc-method nil)
  94.  
  95. (defun optimize-slot-value-by-class-p (class slot-name setf-p)
  96.   (or (not (eq *boot-state* 'complete))
  97.       (let* ((slot-definition (find-slot-definition class slot-name))
  98.          (gfun-name (if setf-p
  99.                 '(setf slot-value-using-class) 'slot-value-using-class))
  100.          (gfun (gdefinition gfun-name))
  101.          (csym (if setf-p 'default-setf-svuc-method 'default-svuc-method))
  102.          (app-methods nil))
  103.     (dolist (method (generic-function-methods gfun))
  104.       (let* ((mspecs (method-specializers method))
  105.          (specs (if setf-p (cdr mspecs) mspecs)))
  106.         (when (and (specializer-applicable-p (first specs) class)
  107.                (specializer-applicable-using-class-p (second specs) class)
  108.                (specializer-applicable-p (third specs) slot-definition))
  109.           (push method app-methods))))
  110.     (and app-methods (null (cdr app-methods))
  111.          (eq (car app-methods)
  112.          (or (symbol-value csym)
  113.              (let* ((specs (if setf-p
  114.                        '(t
  115.                      std-class 
  116.                      standard-object
  117.                      standard-effective-slot-definition)
  118.                        '(std-class 
  119.                      standard-object
  120.                      standard-effective-slot-definition)))
  121.                 (slist (mapcar #'find-class specs)))
  122.                (set csym (get-method gfun nil slist)))))))))
  123.  
  124. (defun lookup-pv (isl args)
  125.   (let* ((class-slot-p nil)
  126.      (elements
  127.       (gathering1 (collecting)
  128.         (iterate ((slot-names (list-elements (%isl-slot-name-lists isl)))
  129.               (arg (list-elements args)))
  130.           (when slot-names
  131.         (let* ((wrapper     (check-wrapper-validity arg))
  132.                (class       (wrapper-class wrapper))
  133.                (class-slots (wrapper-class-slots wrapper)))
  134.           (dolist (slot-name slot-names)
  135.             (if (and (optimize-slot-value-by-class-p
  136.                   class slot-name nil)
  137.                  (optimize-slot-value-by-class-p
  138.                   class slot-name t))
  139.             (let ((index (instance-slot-index wrapper slot-name)))
  140.               (if index
  141.                   (gather1 index)
  142.                   (let ((cell (assq slot-name class-slots)))
  143.                 (if cell
  144.                     (progn (setq class-slot-p t) (gather1 cell))
  145.                     (gather1 nil)))))
  146.             (gather1 nil)))))))))
  147.     (if class-slot-p                ;Sure is a shame Common Lisp doesn't
  148.     (make-permutation-vector elements)    ;give me the right kind of hash table.
  149.     (or (gethash elements *pvs*)
  150.         (setf (gethash elements *pvs*) (make-permutation-vector elements))))))
  151.  
  152. (defun make-permutation-vector (indexes)
  153.   (make-array (length indexes) :initial-contents indexes))
  154.  
  155. (defun make-pv-type-declaration (var)
  156.   `(type simple-vector ,var))
  157.  
  158. (defmacro pvref (pv index)
  159.   `(svref ,pv ,index))
  160.  
  161.  
  162.  
  163. (defun can-optimize-access (var required-parameters env)
  164.   (let ((rebound? (caddr (variable-declaration 'variable-rebinding var env))))
  165.     (if rebound?
  166.     (car (memq rebound? required-parameters))
  167.     (car (memq var required-parameters)))))
  168.  
  169. (defun optimize-slot-value (slots parameter form)
  170.   (destructuring-bind (ignore ignore slot-name)
  171.               form
  172.     (optimize-instance-access slots :read parameter (eval slot-name) nil)))
  173.  
  174. (defun optimize-set-slot-value (slots parameter form)
  175.   (destructuring-bind (ignore ignore slot-name new-value)
  176.               form
  177.     (optimize-instance-access slots :write parameter (eval slot-name) new-value)))
  178.  
  179. ;;;
  180. ;;; The <slots> argument is an alist, the CAR of each entry is the name of
  181. ;;; a required parameter to the function.  The alist is in order, so the
  182. ;;; position of an entry in the alist corresponds to the argument's position
  183. ;;; in the lambda list.
  184. ;;; 
  185. (defun optimize-instance-access (slots read/write parameter slot-name new-value)
  186.   (let* ((parameter-entry (assq parameter slots))
  187.      (slot-entry      (assq slot-name (cdr parameter-entry)))
  188.      (position (position parameter-entry slots)))
  189.     (unless parameter-entry
  190.       (error "Internal error in slot optimization."))
  191.     (unless slot-entry
  192.       (setq slot-entry (list slot-name))
  193.       (push slot-entry (cdr parameter-entry)))
  194.     (ecase read/write
  195.       (:read
  196.     (let ((form (list 'instance-read ''.PV-OFFSET. parameter position 
  197.               `',slot-name)))
  198.       (push form (cdr slot-entry))
  199.       form))
  200.       (:write
  201.     (let ((form (list 'instance-write ''.PV-OFFSET. parameter position 
  202.               `',slot-name '.new-value.)))
  203.       (push form (cdr slot-entry))
  204.       `(let ((.new-value. ,new-value)) ,form))))))
  205.  
  206. (define-walker-template instance-read)
  207. (define-walker-template instance-write)
  208.  
  209.  
  210. (defmacro instance-read (pv-offset parameter position slot-name)
  211.   `(locally
  212.      (declare (optimize (speed 3) (safety 0) (compilation-speed 0)))
  213.      (let ((.INDEX. (pvref .PV. ,pv-offset)))
  214.        (if (and (typep .INDEX. 'fixnum)
  215.         (neq (setq .INDEX. (%svref ,(slot-vector-symbol position) .INDEX.))
  216.              ',*slot-unbound*))
  217.        .INDEX.
  218.        (pv-access-trap ,parameter .PV. ,pv-offset ,slot-name)))))
  219.  
  220. (defmacro instance-write (pv-offset parameter position slot-name new-value)
  221.   `(locally
  222.      (declare (optimize (speed 3) (safety 0) (compilation-speed 0)))
  223.      (let ((.INDEX. (pvref .PV. ,pv-offset)))
  224.        (if (typep .INDEX. 'fixnum)
  225.        (setf (%svref ,(slot-vector-symbol position) .INDEX.) ,new-value)
  226.        (pv-access-trap ,parameter .PV. ,pv-offset ,slot-name ,new-value)))))
  227.  
  228. (defun pv-access-trap (instance pv offset slot-name &optional (new-value nil nvp))
  229.   ;;
  230.   ;; First thing we do is a quick check to see if this is a class variable.
  231.   ;; This could be done inline by moving it to INSTANCE-READ/WRITE.  I did
  232.   ;; not do that because I don't know whether its worth it.
  233.   ;;
  234.   (let ((cell (pvref pv offset)))
  235.     (if (consp cell)
  236.     (if nvp (setf (cdr cell) new-value) (cdr cell))
  237.     ;;
  238.     ;; Well, now do a slow trap.
  239.     ;; 
  240.     (if nvp
  241.         (setf (slot-value instance slot-name) new-value)
  242.         (slot-value instance slot-name)))))
  243.  
  244. ;;;
  245. ;;; This magic function has quite a job to do indeed.
  246. ;;;
  247. ;;; The careful reader will recall that <slots> contains all of the optimized
  248. ;;; slot access forms produced by OPTIMIZE-INSTANCE-ACCESS.  Each of these is
  249. ;;; a call to either INSTANCE-READ or INSTANCE-WRITE.
  250. ;;;
  251. ;;; At the time these calls were produced, the first argument was specified as
  252. ;;; the symbol .PV-OFFSET.; what we have to do now is convert those pv-offset
  253. ;;; arguments into the actual number that is the correct offset into the pv.
  254. ;;;
  255. ;;; But first, oh but first, we sort <slots> a bit so that for each argument
  256. ;;; we have the slots in alphabetical order.  This canonicalizes the ISL's a
  257. ;;; bit and will hopefully lead to having fewer PV's floating around.  Even
  258. ;;; if the gain is only modest, it costs nothing.
  259. ;;;  
  260. (defun slot-name-lists-from-slots (slots)
  261.   (mapcar #'(lambda (parameter-entry) (mapcar #'car (cdr parameter-entry)))
  262.       (mutate-slots slots)))
  263.  
  264. (defun mutate-slots (slots)
  265.   (let ((sorted (sort-slots slots))
  266.     (pv-offset -1))
  267.     (dolist (parameter-entry sorted)
  268.       (dolist (slot-entry (cdr parameter-entry))
  269.     (incf pv-offset)    
  270.     (dolist (form (cdr slot-entry))
  271.       (setf (cadr form) pv-offset))))
  272.     sorted))
  273.  
  274. (defun sort-slots (slots)
  275.   (mapcar #'(lambda (parameter-entry)
  276.           (cons (car parameter-entry)
  277.             (sort (cdr parameter-entry)    ;slot entries
  278.               #'(lambda (a b)
  279.                   (string-lessp (symbol-name (car a))
  280.                         (symbol-name (car b)))))))
  281.       slots))
  282.  
  283.  
  284. ;;;
  285. ;;; This needs to work in terms of metatypes and also needs to work for
  286. ;;; automatically generated reader and writer functions.
  287. ;;;   
  288. (defun add-pv-binding (method-body plist required-parameters)
  289.   (let* ((isl (getf plist :isl))
  290.      (isl-cache-symbol (make-symbol "isl-cache")))
  291.     (nconc plist (list :isl-cache-symbol isl-cache-symbol))
  292.     (with-gathering ((slot-variables (collecting))
  293.              (metatypes (collecting)))
  294.       (iterate ((slots (list-elements isl))
  295.             (i (interval :from 0)))
  296.         (cond (slots
  297.            (gather (slot-vector-symbol i) slot-variables)
  298.            (gather 'standard-instance     metatypes))
  299.           (t
  300.            (gather nil slot-variables)
  301.            (gather t   metatypes))))
  302.       `((let ((.ISL. (locally (declare (special ,isl-cache-symbol)) ,isl-cache-symbol))
  303.           (.PV. *empty-vector*)
  304.           ,@(remove nil slot-variables))
  305.       (declare ,(make-isl-type-declaration '.ISL.)
  306.            ,(make-pv-type-declaration '.PV.))
  307.     
  308.       (let* ((cache (%isl-cache .ISL.))
  309.          (size  (%isl-size  .ISL.))
  310.          (mask  (%isl-mask  .ISL.))
  311.          (field (%isl-field .ISL.)))
  312.         ,(generating-lap-in-lisp '(cache size mask field)
  313.                      required-parameters
  314.            (flatten-lap
  315.          (emit-pv-dlap required-parameters metatypes slot-variables))))
  316.  
  317.       ,@method-body)))))
  318.  
  319. (defun emit-pv-dlap (required-parameters metatypes slot-variables)
  320.   (let* ((slot-regs (mapcar #'(lambda (sv) (and sv (operand :lisp-variable sv)))
  321.                 slot-variables))
  322.      (wrappers (dlap-wrappers metatypes))
  323.      (nwrappers (remove nil wrappers)))
  324.     (flet ((wrapper-moves (miss-label)
  325.          (dlap-wrapper-moves wrappers required-parameters metatypes miss-label slot-regs)))
  326.       (prog1 (emit-dlap-internal
  327.            nwrappers                   ;wrapper-regs
  328.            (wrapper-moves 'pv-miss)    ;wrapper-moves
  329.            (opcode :exit-lap-in-lisp)  ;hit
  330.            (flatten-lap           ;miss
  331.          (opcode :label 'pv-miss)
  332.          (opcode :move
  333.              (operand :lisp `(primary-pv-cache-miss
  334.                       .ISL. ,@required-parameters))
  335.              (operand :lisp-variable '.PV.))
  336.          (apply #'flatten-lap (wrapper-moves 'pv-wrapper-miss)) ; -- Maybe the wrappers have changed.
  337.          (opcode :label 'pv-wrapper-miss)
  338.          (opcode :exit-lap-in-lisp))                               
  339.            'pv-miss                ;miss-label
  340.            (operand :lisp-variable '.PV.)) ;value-reg
  341.        (mapc #'deallocate-register nwrappers)))))
  342.  
  343. (defun compute-primary-pv-cache-size (slot-name-lists)
  344.   (compute-cache-parameters (- (length slot-name-lists) (count nil slot-name-lists))
  345.                 t
  346.                 2))
  347.  
  348. (defun pv-cache-limit-fn (nlines)
  349.   (default-limit-fn nlines))
  350.  
  351. (defun primary-pv-cache-miss (isl &rest args)
  352.   (let* ((wrappers
  353.        (gathering1 (collecting) 
  354.          (iterate ((slot-names (list-elements (%isl-slot-name-lists isl)))
  355.                (arg        (list-elements args)))
  356.            (when slot-names (gather1 (check-wrapper-validity arg))))))
  357.      (pv (lookup-pv isl args))
  358.      (field (%isl-field isl))
  359.      (cache (%isl-cache isl))
  360.      (nkeys (length wrappers)))
  361.     (multiple-value-bind (new-field new-cache new-mask new-size)
  362.     (fill-cache field cache nkeys t #'pv-cache-limit-fn
  363.             (if (= nkeys 1) (car wrappers) wrappers)
  364.             pv)
  365.       (when (or (not (= new-field field))
  366.         (not (eq new-cache cache)))
  367.     (without-interrupts            ;NOTE:
  368.       (setf (%isl-field isl) new-field    ; There is no mechanism to
  369.         (%isl-cache isl) new-cache    ; synchronize the reading of
  370.         (%isl-size  isl) new-size    ; these values.  But, this is
  371.         (%isl-mask  isl) new-mask))    ; a safe order to write them
  372.                         ; in.  Stricly speaking, the
  373.                         ; use of without-interrupts
  374.                         ; is superfluous.
  375.     (when (neq new-cache cache) (free-cache cache))))
  376.     pv))
  377.  
  378.  
  379.  
  380. (defmethod wrapper-fetcher ((class standard-class))
  381.   'std-instance-wrapper)
  382.  
  383. (defmethod slots-fetcher ((class standard-class))
  384.   'std-instance-slots)
  385.  
  386. (defmethod raw-instance-allocator ((class standard-class))
  387.   '%%allocate-instance--class)
  388.